home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / subclass / example2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-07  |  2.9 KB  |  118 lines
  1. unit example2;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   ExtCtrls;
  8.  
  9. type
  10.   Texample2 = class(TCustomPanel)
  11.   private
  12.    fNewWindowProc : Pointer;  {pointer to our window function}
  13.    fOldWindowProc : Pointer;   {previous window function }
  14.    fTargetHandle : hWnd;
  15.    fSubClassDone : boolean;
  16.    Procedure NewFormFunction(var msg : tmessage);
  17.    procedure WMPAINT(var Message: TMessage); message WM_PAINT;
  18.   protected
  19.     { Protected declarations }
  20.   public
  21.     constructor create(aOwner: tcomponent); override;
  22.     procedure turnOnSubClassing;
  23.     procedure TurnOffSubClassing;
  24.   published
  25.     property Align;
  26.     property Alignment;
  27.     property BevelInner;
  28.     property BevelOuter;
  29.     property BevelWidth;
  30.     property BorderWidth;
  31.     property BorderStyle;
  32.     property DragCursor;
  33.     property DragMode;
  34.     property Enabled;
  35.     property FullRepaint;
  36.     property Caption;
  37.     property Color;
  38.     property Ctl3D;
  39.     property Font;
  40.     property Locked;
  41.     property ParentColor;
  42.     property ParentCtl3D;
  43.     property ParentFont;
  44.     property ParentShowHint;
  45.     property PopupMenu;
  46.     property ShowHint;
  47.     property TabOrder;
  48.     property TabStop;
  49.     property Visible;
  50.     property OnClick;
  51.     property OnDblClick;
  52.     property OnDragDrop;
  53.     property OnDragOver;
  54.     property OnEndDrag;
  55.     property OnEnter;
  56.     property OnExit;
  57.     property OnMouseDown;
  58.     property OnMouseMove;
  59.     property OnMouseUp;
  60.     property OnResize;
  61.     property OnStartDrag;
  62.   end;
  63.  
  64. procedure Register;
  65.  
  66. implementation
  67.  
  68. constructor Texample2.create(aOwner: tcomponent);
  69. begin
  70.   inherited create(aowner);
  71.   fsubclassDone := false;
  72.   bevelInner := bvLowered;
  73.   bevelWidth := 3;
  74.   caption := 'Subclassing off';
  75.   end;
  76.  
  77. procedure Texample2.NewFormFunction(var msg : tmessage);
  78. begin
  79.   case msg.msg of
  80.      WM_LBUTTONDOWN : color := clFuchsia;
  81.      WM_RBUTTONDOWN : color := clTeal;
  82.      end;
  83.   msg.Result := CallWindowProc(fOldWindowProc, fTargetHandle, msg.Msg, msg.wParam, msg.LParam);
  84. end;
  85.  
  86. procedure Texample2.WMPAINT(var Message: TMessage);
  87. begin
  88.   inherited;
  89.   if not fSubclassDone
  90.     then TurnOnSubclassing;
  91. end;
  92.  
  93. procedure Texample2.turnOnSubClassing;
  94. begin
  95.    fTargetHandle := parent.handle;
  96.    fNewWindowProc := MakeObjectInstance(NewFormFunction);
  97.    fOldWindowProc := Pointer(SetWindowLong(fTargetHandle, GWL_WNDPROC, LongInt(fNewWindowProc)));
  98.    caption := 'eg2: Subclassing on';
  99.    fsubclassDone := true;
  100. end;
  101.  
  102. procedure Texample2.TurnOffSubClassing;
  103. begin
  104.    SetWindowLong(fTargetHandle, GWL_WNDPROC, longint(fOldWindowProc));
  105.    FreeObjectInstance(fNewWindowProc);
  106.    caption := 'eg2: Subclassing off';
  107.    color := clBtnFace;
  108.    fSubclassDone := false;
  109. end;
  110.  
  111.  
  112. procedure Register;
  113. begin
  114.   RegisterComponents('Samples', [Texample2]);
  115. end;
  116.  
  117. end.
  118.